home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / PARSER / KPARS_00 / KSTRING.PAS < prev   
Pascal/Delphi Source File  |  1993-09-02  |  49KB  |  1,599 lines
  1. {$A-}
  2. {$B-}
  3. {$D-}
  4. {$E-}
  5. {$F+}
  6. {$I-}
  7. {$L-}
  8. {$N-}
  9. {$O+}
  10. {$R-}  {Range checking off}
  11. {$S-}
  12. {$V-}
  13.  
  14. UNIT Kstring;
  15. {+H
  16. ---------------------------------------------------------------------------
  17.   File        - Kstring.PAS
  18.  
  19.   Copyright (c) Klingon Software Services 1987..1993 except where noted.
  20.                 All rights reserved.
  21.  
  22.   Author      - Keith S. Brown (except where otherwise noted)
  23.                 Surface mail:              Email:
  24.                   K.Brown
  25.                   2437 Bay Area Blvd #20
  26.                   Houston, TX 77058 (USA)  Voice:713-486-6765
  27.  
  28.   Purpose     - String and character manipulation routines.
  29.  
  30.   Language    - Borland International's Turbo Pascal V:4.x+ for MS-DOS
  31.  
  32.   Requires    - Turbo Power Professional's TPSTRING.PAS unit.
  33.  
  34.   Reference   - See documentation of individual proc/funct.
  35.   Revised     - 1987.xxxx (KSB) Wrote initial version.
  36.               - 1991.0613 (KSB) Added ArrayToString. Renamed StringConvert to
  37.                 StringToArray.  Added LastChar, NextPos, RightPos, Chop, ChopCh, Plural, and InSet.
  38.               - 1991.0625 (KSB) Added WeightToLbOzStr
  39.               - 1991.0828 (KSB) Added Replicate function.
  40.               - 1991.0904 (KSB) Fixed DoubleCheck.
  41.               - 1992.0330 (KSB) Added character test functions.
  42.               - 1992.0407 (KSB) Added StringToReal function.
  43.               - 1992.0423 (KSB) Mod'd Long2LStr, StringToLong, StringToReal, DollarsToPennies.
  44.               - 1992.0930 (KSB) Added ChOfStr, Squeeze, Squeeze_ANP, SqueezeAN, Reverse, IsPunct, IsExtended.
  45. ---------------------------------------------------------------------------}
  46. INTERFACE
  47. USES
  48.   TPstring;   {from TurboPower Professional V:5.07}
  49.  
  50.               {------------------------------
  51.               {Trimming & padding}
  52.  
  53.               {Fix functions trim before padding}
  54. {}FUNCTION  Fix(s:STRING; len:BYTE):STRING;
  55. {}FUNCTION  FixCh(s:STRING; Ch:CHAR; len:BYTE):STRING;
  56. {}FUNCTION  LeftFix(s:STRING; len:BYTE):STRING;
  57. {}FUNCTION  LeftFixCh(s:STRING; Ch:CHAR; len:BYTE):STRING;
  58.  
  59.               {Chop functions trimright before padding}
  60. {}FUNCTION  Chop(s:STRING; len:BYTE):STRING;
  61. {}FUNCTION  ChopCh(s:STRING; Ch:CHAR; len:BYTE):STRING;
  62.  
  63.  
  64.               {------------------------------
  65.               {Parsing, splitting, etc}
  66.  
  67. {}FUNCTION  Before(source,target:STRING):STRING;
  68. {}FUNCTION  After(source,target:STRING):STRING;
  69. {}FUNCTION  Parse(VAR source:STRING; separator:STRING):STRING;
  70. {}FUNCTION  DoubleCheck(s:STRING; Ch:CHAR):STRING;
  71. {}FUNCTION  Replace(s,substr,newstr:STRING):STRING;
  72. {}FUNCTION  ReplaceAll(s,substr,newstr:STRING):STRING;
  73.  
  74. {}FUNCTION  OverWrite(s:STRING; INDEX:BYTE; subStr:STRING): STRING;
  75. {}FUNCTION  LastChar(s:STRING):CHAR;
  76. {}FUNCTION  NextPos(substr,s: STRING; lastpos:BYTE; ignorecase:BOOLEAN):BYTE;
  77. {}FUNCTION  RightPos(substr,s:STRING; lastPos:BYTE; ignoreCase:BOOLEAN):BYTE;
  78. {}FUNCTION  Replicate(s:STRING; Len:BYTE):STRING;
  79. {}FUNCTION  SeekCharRange(s: STRING; ch1,ch2:CHAR; StartPos:BYTE):BYTE;
  80.  
  81. {}FUNCTION  ChOfStr(s:STRING; INDEX:BYTE):CHAR;
  82. {}FUNCTION  StrEnd(s:STRING):BYTE;
  83.  
  84. {}FUNCTION  Squeeze(s:STRING):STRING;      {leaves alphanums, punctuation}
  85. {}FUNCTION  Squeeze_ANP(s:STRING):STRING;  {leaves alphanums, '.' & '_'}
  86. {}FUNCTION  SqueezeAN(s:STRING):STRING;    {leaves alphanums only}
  87. {}FUNCTION  Reverse(s:STRING):STRING;      {reverses S}
  88.  
  89.  
  90.               {------------------------------
  91.               {formatting}
  92.  
  93. {}FUNCTION  PhoneStr(phone:STRING):STRING;
  94. {}FUNCTION  FullPhoneStr(phone:STRING):STRING;
  95. {}FUNCTION  PennyStr(Pennies:LongINT; MaxLen:BYTE; DollarSign:BOOLEAN):STRING;
  96. {}FUNCTION  Plural(num:LongINT; thing:STRING):STRING;
  97. {}FUNCTION  Cap1stChar(s:STRING):STRING;
  98. {}FUNCTION  Long2LStr(L:LongINT; width:BYTE):STRING;
  99. {}FUNCTION  BankStr(pennies:LongINT):STRING;
  100. {}FUNCTION  Long2Text(L:LongINT):STRING;
  101. {}FUNCTION  WeightToLbOzStr(w:LongINT):STRING;
  102.  
  103.  
  104.               {------------------------------
  105.               {type conversion}
  106.  
  107. {}FUNCTION  StringToLong(s:STRING):LongINT;
  108. {}PROCEDURE StringToArray(StrP:STRING; VAR CharArrayP; Len: BYTE);
  109. {}FUNCTION  ArrayToString(VAR CharArrayP; start:WORD; Len:BYTE):STRING;
  110. {}FUNCTION  StringToReal(s:STRING):REAL;
  111. {}FUNCTION  DollarsToPennies(s:STRING):LongINT;
  112.  
  113.  
  114.               {------------------------------
  115.               {Pattern matching}
  116.  
  117. {}FUNCTION  Matches(s,pattern:STRING):BOOLEAN;
  118. {}FUNCTION  IsAfter(s1,s2,s:STRING):BOOLEAN;
  119. {}FUNCTION  IsBefore(s1,s2,s:STRING):BOOLEAN;
  120. {}FUNCTION  Indented(s:STRING):BYTE;
  121.  
  122.  
  123.               {------------------------------
  124.               {character tests}
  125.  
  126. {}FUNCTION  IsLetter(c:CHAR):BOOLEAN;          {T if c is 'A'..'Z','a'..'z'}
  127. {}FUNCTION  IsLower(c:CHAR):BOOLEAN;           {T if c is 'a'..'z'}
  128. {}FUNCTION  IsUpper(c:CHAR):BOOLEAN;           {T if c is 'A'..'Z'}
  129.  
  130. {}FUNCTION  IsDigit(c:CHAR):BOOLEAN;           {T if c is '0'..'9'}
  131. {}FUNCTION  IsHexDigit(c:CHAR):BOOLEAN;        {T if c is hex digit}
  132.  
  133. {}FUNCTION  IsAlphaNum(c:CHAR):BOOLEAN;        {T if c is letter or number}
  134. {}FUNCTION  IsAscii(c:CHAR):BOOLEAN;           {T if c is #000..#127}
  135. {}FUNCTION  IsCntrl(c:CHAR):BOOLEAN;           {T if c is #000..#021,#127}
  136. {}FUNCTION  IsExtended(c:CHAR):BOOLEAN;        {T if c is #128..#255}
  137. {}FUNCTION  IsPrint(c:CHAR):BOOLEAN;           {T if c is #032..#126}
  138. {}FUNCTION  IsPunct(c:CHAR):BOOLEAN;           {T if c is a punctuation char}
  139. {}FUNCTION  IsSpace(c:CHAR):BOOLEAN;           {T if c is space,tab,CR,LF,VT,FF}
  140.  
  141.  
  142.               {------------------------------
  143.               {other}
  144.  
  145. {}FUNCTION  InSet(VAR someSet; VAR setMember):BOOLEAN;
  146. {}FUNCTION  CountOf(s:STRING; cs:CharSet):BYTE;
  147.  
  148.      {====================================================================}
  149.  
  150. IMPLEMENTATION
  151.  
  152.               {------------------------------
  153.               {Trimming & Padding}
  154.  
  155.  
  156. {}FUNCTION Fix(s:STRING; len:BYTE):STRING;
  157. {+H
  158. ---------------------------------------------------------------------------
  159.   Purpose     - Remove all leading and trailing white space from S.
  160.   Declaration - Fix(s:STRING; len:BYTE)
  161.   Result type - string.
  162.   Remarks     - If the length of S is greater than LEN then truncate it to
  163.                 LEN, else right pad with blanks to length LEN.
  164. ---------------------------------------------------------------------------}
  165.   VAR
  166.     L    : BYTE ABSOLUTE s;
  167.   BEGIN
  168.     s := Trim(s);
  169.     IF L > len THEN
  170.       L := len
  171.     ELSE
  172.       s := Pad(s,len);
  173.  
  174.     Fix:= s;
  175. {}END {Fix};
  176.  
  177.  
  178.  
  179.  
  180. {}FUNCTION FixCh(s:STRING; Ch:CHAR; len:BYTE):STRING;
  181. {+H
  182. ---------------------------------------------------------------------------
  183.   Purpose     - Remove all leading and trailing white space from S.
  184.   Declaration - FixCh(s:STRING; Ch:CHAR; len:BYTE)
  185.   Result type - string.
  186.   Remarks     - If the length of S is greater than LEN then truncate it to
  187.                 LEN, else right pad with it with Ch to length LEN.
  188. ---------------------------------------------------------------------------}
  189.   VAR
  190.     L    : BYTE ABSOLUTE s;
  191.   BEGIN
  192.     s := Trim(s);
  193.     IF L > len THEN
  194.       L := len
  195.     ELSE
  196.       s := PadCh(s,Ch,len);
  197.  
  198.     FixCh := s;
  199. {}END {FixCh};
  200.  
  201.  
  202.  
  203.  
  204. {}FUNCTION LeftFix(s:STRING; len:BYTE):STRING;
  205. {+H
  206. ---------------------------------------------------------------------------
  207.   Purpose     - Remove all leading and trailing white space from S.
  208.   Declaration - LeftFix(s:STRING; len:BYTE)
  209.   Result type - string.
  210.   Remarks     - If the length of S is greater than LEN then truncate it to
  211.                 LEN, else left pad with blanks to length LEN.
  212. ---------------------------------------------------------------------------}
  213.   VAR
  214.     L    : BYTE ABSOLUTE s;
  215.   BEGIN
  216.     s := Trim(s);
  217.     IF L > len THEN
  218.       L := len
  219.     ELSE
  220.       s := LeftPad(s,len);
  221.  
  222.     LeftFix:= s;
  223. {}END {LeftFix};
  224.  
  225.  
  226.  
  227.  
  228. {}FUNCTION LeftFixCh(s:STRING; Ch:CHAR; len:BYTE):STRING;
  229. {+H
  230. ---------------------------------------------------------------------------
  231.   Purpose     - Remove all leading and trailing white space from S.
  232.   Declaration - LeftFixCh(s:STRING; Ch:CHAR; len:BYTE)
  233.   Result type - string.
  234.   Remarks     - If the length of S is greater than LEN then truncate it to
  235.                 LEN, else left pad with it with Ch to length LEN.
  236. ---------------------------------------------------------------------------}
  237.   VAR
  238.     L    : BYTE ABSOLUTE s;
  239.   BEGIN
  240.     s := Trim(s);
  241.     IF L > len THEN
  242.       L := len
  243.     ELSE
  244.       s := LeftPadCh(s,Ch,len);
  245.  
  246.     LeftFixCh := s;
  247. {}END {LeftFixCh};
  248.  
  249.  
  250.  
  251.  
  252. {}FUNCTION  Chop(s:STRING; len:BYTE):STRING;
  253. {+H
  254. ---------------------------------------------------------------------------
  255.   Purpose     - Truncate S from the right if S is longer than LEN.
  256.   Declaration - Chop(s:STRING; len:BYTE)
  257.   Result type - string.
  258.   Remarks     - Pad S with blanks if S is shorter than LEN.
  259. ---------------------------------------------------------------------------}
  260.   VAR
  261.     L    : BYTE ABSOLUTE s;
  262.   BEGIN
  263.     IF L > len THEN
  264.       L := len
  265.     ELSE
  266.       s := Pad(s,len);
  267.  
  268.     Chop := s;
  269. {}END {Chop};
  270.  
  271.  
  272.  
  273.  
  274. {}FUNCTION  ChopCh(s:STRING; Ch:CHAR; len:BYTE):STRING;
  275. {+H
  276. ---------------------------------------------------------------------------
  277.   Purpose     - Truncate S from the right if S is longer than LEN.
  278.   Declaration - ChopCh(s:STRING; Ch:CHAR; len:BYTE)
  279.   Result type - string.
  280.   Remarks     - Pad S with CH characters if S is shorter than LEN.
  281. ---------------------------------------------------------------------------}
  282.   VAR
  283.     L    : BYTE ABSOLUTE s;
  284.   BEGIN
  285.     IF L > len THEN
  286.       L := len
  287.     ELSE
  288.       s := PadCh(s,Ch,len);
  289.  
  290.     ChopCh := s;
  291. {}END {ChopCh};
  292.  
  293.  
  294.  
  295.  
  296.               {------------------------------
  297.               {Parsing, splitting, etc.}
  298.  
  299.  
  300. {}FUNCTION Before(source,target:STRING):STRING;
  301. {+H
  302. ---------------------------------------------------------------------------
  303.   Purpose     - Returns all of the source string up to but not including
  304.                 the first occurance of the target string.
  305.   Declaration - Before(source,target:STRING)
  306.   Result type - string.
  307.   Author      - Dick Pountain. Byte; Dec 1988; Pp.307-314
  308. ---------------------------------------------------------------------------}
  309.   BEGIN
  310.     IF Pos(target,source) = 0 THEN
  311.       Before := source
  312.     ELSE
  313.       Before := Copy(source,1,Pred(Pos(target,source)));
  314. {}END {Before};
  315.  
  316.  
  317.  
  318.  
  319. {}FUNCTION After(source,target:STRING):STRING;
  320. {+H
  321. ---------------------------------------------------------------------------
  322.   Purpose     - Returns all of the source string that follows (but does not
  323.                 include) the first occurance of the target string.
  324.   Declaration - After(source,target:STRING)
  325.   Result type - string.
  326.   Author      - Dick Pountain. Byte; Dec 1988; Pp.307-314
  327. ---------------------------------------------------------------------------}
  328.   BEGIN
  329.     IF Pos(target,source) = 0 THEN
  330.       After := ''
  331.     ELSE
  332.       After := Copy(source,Pos(target,source)+Length(target),Length(source));
  333. {}END {After};
  334.  
  335.  
  336.  
  337.  
  338. {}FUNCTION Parse(VAR source:STRING; separator:STRING):STRING;
  339. {+H
  340. ---------------------------------------------------------------------------
  341.   Purpose     - Treats SOURCE as a stream of tokens, separated by a string
  342.                 delimiter called SEPARATOR.  Each call to PARSE returns a
  343.                 single new token from the stream.  When the tokens are all
  344.                 used up, it continues to return null strings.
  345.   Warning     - This function modifies its arguments, ie., it lacks idempotency.
  346.   Declaration - Parse(VAR source:STRING; separator:STRING)
  347.   Result type - string.
  348.   Author      - Dick Pountain. Byte; Dec 1988; Pp.307-314
  349. ---------------------------------------------------------------------------}
  350.   BEGIN
  351.     Parse := Before(source,separator);
  352.     source:= After(source,separator);
  353. {}END {Parse};
  354.  
  355.  
  356.  
  357.  
  358. {}FUNCTION DoubleCheck(s:STRING; Ch:CHAR):STRING;
  359. {+H
  360. ---------------------------------------------------------------------------
  361.   Purpose     - Removes all multiple separators from the input string S.
  362.   Declaration - DoubleCheck(s:STRING; Ch:CHAR)
  363.   Result type - string.
  364.   Author      - S. Balch.  Byte; Apr 1989; Pp.40
  365.   Revised     - 1991.0903 (KSB) Added check for ch+ch to prevent ch from
  366.                 being appended if ch+ch is not found.
  367. ---------------------------------------------------------------------------}
  368.   BEGIN
  369.     IF Pos(ch+ch,s) > 0 THEN
  370.       REPEAT
  371.         s := Before(s,ch+ch)+ch+After(s,ch+ch);
  372.       UNTIL After(s,Ch+Ch) = '';
  373.       DoubleCheck := s;
  374. {}END {DoubleCheck};
  375.  
  376.  
  377.  
  378.  
  379. {}FUNCTION  Replace(s,substr,newstr:STRING):STRING;
  380. {+H
  381. ---------------------------------------------------------------------------
  382.   Purpose     - Replace the first occurance of SUBSTR found in S with NEWSTR
  383.   Declaration - Replace(s,substr,newstr:STRING)
  384.   Result type - string.
  385. ---------------------------------------------------------------------------}
  386.   BEGIN
  387.     IF Pos(subStr,s)>0 THEN
  388.       Replace := Before(s,substr)+newStr+After(s,subStr)
  389.     ELSE
  390.       Replace := s;
  391. {}END {Replace};
  392.  
  393.  
  394.  
  395.  
  396. {}FUNCTION  ReplaceAll(s,substr,newstr:STRING):STRING;
  397. {+H
  398. ---------------------------------------------------------------------------
  399.   Purpose     - Replace all occurances of SUBSTR found in S with NEWSTR.
  400.   Declaration - ReplaceAll(s,substr,newstr:STRING)
  401.   Result type - string.
  402. ---------------------------------------------------------------------------}
  403.   BEGIN
  404.     WHILE Pos(subStr,s)>0 DO
  405.       s := Replace(s,substr,newstr);
  406.     ReplaceAll := s;
  407. {}END {ReplaceAll};
  408.  
  409.  
  410.  
  411.  
  412. {}FUNCTION OverWrite(s:STRING; INDEX:BYTE; subStr:STRING): STRING;
  413. {+H
  414. ---------------------------------------------------------------------------
  415.   Purpose     - Overwrites string S with substring SUBSTR starting at position
  416.                 INDEX of S.  If INDEX is greater than the length of S, S is
  417.                 is blank extended.  Max returned string length is 255.
  418.   Declaration - OverWrite(s:STRING; index:BYTE; subStr:STRING)
  419.   Result type - string.
  420. ---------------------------------------------------------------------------}
  421.   VAR
  422.     L1   : BYTE ABSOLUTE s;        { length of S }
  423.     L2   : BYTE ABSOLUTE subStr;   { length of substring }
  424.     i    : BYTE;                   { substring index }
  425.   BEGIN
  426.     IF INDEX > L1 THEN
  427.       s := s + CharStr(' ',Pred(INDEX-L1)) + subStr
  428.     ELSE BEGIN
  429.       i := 1;
  430.       WHILE (INDEX < 256) AND (i <= L2) DO BEGIN
  431.         s[INDEX] := SubStr[i];
  432.         Inc(INDEX); Inc(i);
  433.       END {WHILE};
  434.       IF Pred(INDEX) > L1 THEN
  435.         s[0] := Chr(Pred(INDEX));
  436.     END {IF};
  437.     OverWrite := s;
  438. {}END {OverWrite};
  439.  
  440.  
  441.  
  442.  
  443. {}FUNCTION  LastChar(s:STRING):CHAR;
  444. {+H
  445. ---------------------------------------------------------------------------
  446.   Purpose     - Returns the last character of a string.
  447.   Declaration - LastChar(s:STRING)
  448.   Result type - char.
  449. ---------------------------------------------------------------------------}
  450.   BEGIN
  451.     IF s = '' THEN
  452.       LastChar := #0
  453.     ELSE
  454.       LastChar := s[Length(s)];
  455. {}END {LastChar};
  456.  
  457.  
  458.  
  459.  
  460. {}FUNCTION  NextPos(substr,s:STRING; lastpos:BYTE; ignorecase:BOOLEAN):BYTE;
  461. {+H
  462. ---------------------------------------------------------------------------
  463.   Purpose     - Searches for a substring in a string starting at the 'lastpos'
  464.                 character in 's'.  If 'ignorecase' is True, then both strings
  465.                 are first converted to uppercase.  Returns the location of the
  466.                 next occurrence of 'substr' within 's' or 0 if not found
  467.                 'lastpos' need not be a valid position.  Char's to the left of
  468.                 'lastpos' will not be examined.
  469.   Declaration - NextPos(substr,s:STRING; lastpos:BYTE; ignorecase:BOOLEAN)
  470.   Result type - byte.
  471. ---------------------------------------------------------------------------}
  472.   VAR
  473.     npos : BYTE;
  474.     i    : BYTE;
  475.   BEGIN
  476.     s := Copy(s,Succ(lastpos),Length(s)-lastpos); {Trim the search string}
  477.  
  478.     IF ignorecase THEN BEGIN                      {If case is to be ignored,}
  479.       s      := StUpCase(s);                      { then convert the strings}
  480.       subStr := StUpCase(subStr);                 { to uppercase}
  481.     END {IF};
  482.  
  483.     npos := Pos( substr, s );
  484.     IF npos > 0 THEN
  485.       npos := npos + lastpos;
  486.  
  487.     Nextpos := npos;
  488. {}END {NextPos};
  489.  
  490.  
  491.  
  492.  
  493. {}FUNCTION  RightPos(substr,s:STRING; lastPos:BYTE; ignoreCase:BOOLEAN):BYTE;
  494. {+H
  495. ---------------------------------------------------------------------------
  496.   Purpose     - Searches for a substring in a string starting at the 'lastpos'
  497.                 character in 's' & working backwards towards the beginning of
  498.                 the string.  If the 'ignorecase' is True, then both strings are
  499.                 first converted to uppercase.  Returns the location of the next
  500.                 (right) occurrence of 'substr' within 's' or 0 if not found.
  501.                 'lastpos' need not be a valid position.  Characters to the
  502.                 right of 'lastpos' will not be examined (as the head of the
  503.                 substring).
  504.   Declaration - RightPos(substr,s:STRING; lastPos:BYTE; ignoreCase:BOOLEAN)
  505.   Result type - byte.
  506. ---------------------------------------------------------------------------}
  507.   VAR
  508.     npos : BYTE;
  509.     i    : BYTE;
  510.     temp : STRING;
  511.   BEGIN
  512.     temp := Copy( s, 1, lastPos);                 {Trim the search string}
  513.  
  514.     IF ignorecase THEN BEGIN                      {If case is to be ignored,}
  515.       temp   := StUpCase(temp);                   { then convert the strings}
  516.       substr := StUpCase(substr);                 { to uppercase}
  517.     END {IF};
  518.  
  519.     npos := 0;
  520.     i    := lastPos;
  521.     WHILE (npos=0) AND (i>0) DO BEGIN
  522.       s    := Copy(temp,i,lastPos);
  523.       npos := Pos( substr, s );
  524.       Dec(i);
  525.     END {WHILE};
  526.  
  527.     Rightpos := npos+i;
  528. {}END {RightPos};
  529.  
  530.  
  531.  
  532.  
  533. {}FUNCTION  Replicate(s:STRING; Len:BYTE):STRING;
  534. {+H
  535. ---------------------------------------------------------------------------
  536.   Purpose     - Return a string of length LEN filled with S.
  537.   Declaration - Replicate(s:STRING; Len:BYTE)
  538.   Result type - string.
  539. ---------------------------------------------------------------------------}
  540.   VAR
  541.     t    : STRING;
  542.     L    : BYTE ABSOLUTE s;
  543.     m    : BYTE ABSOLUTE t;
  544.   BEGIN
  545.     CASE L OF
  546.       0 : Replicate := '';                        {zero length pattern}
  547.       1 : Replicate := CharStr(s[1],Len);         {1 char pattern}
  548.       ELSE
  549.                                         {multiple char pattern}
  550.         t := '';
  551.       WHILE m < Len DO
  552.         t := t + s;
  553.       t[0] := Chr(Len);
  554.       Replicate := t;
  555.     END {CASE};
  556. {}END {Replicate};
  557.  
  558.  
  559.  
  560.  
  561. {}FUNCTION SeekCharRange(s: STRING; ch1,ch2:CHAR; StartPos:BYTE):BYTE;
  562. {+H
  563. ---------------------------------------------------------------------------
  564.   Purpose     - Searches for the first of a range of characters that lie
  565.                 between CH1 and CH2 (inclusive) in S.
  566.   Declaration - SeekCharRange(s: STRING; ch1,ch2:CHAR; StartPos:BYTE)
  567.   Result type - byte.
  568.   Remarks     - If STARTPOS is greater than 1, then only that portion of S
  569.                 to the right of STARTPOS (inclusive) will be examined.
  570. ---------------------------------------------------------------------------}
  571.   VAR
  572.     L    : BYTE ABSOLUTE s;
  573.     sPos : WORD;
  574.     Found: BOOLEAN;
  575.   BEGIN
  576.     IF StartPos <= L THEN BEGIN
  577.       sPos := StartPos;
  578.       REPEAT
  579.         Found := (s[sPos] >= Ch1) AND (s[sPos] <= Ch2);
  580.         Inc(sPos);
  581.       UNTIL Found OR (sPos > L);
  582.  
  583.       IF Found THEN
  584.         SeekCharRange := Pred(sPos)
  585.       ELSE
  586.         SeekCharRange := 0;
  587.     END ELSE
  588.       SeekCharRange := 0;
  589. {}END {SeekCharRange};
  590.  
  591.  
  592.  
  593.  
  594. {}FUNCTION  ChOfStr(s:STRING; INDEX:BYTE):CHAR;
  595. {+H
  596. ---------------------------------------------------------------------------
  597.   Purpose     - Return the INDEX'th character of S.
  598.   Declaration - ChOfStr(s:STRING; index:BYTE)
  599.   Result type - char.
  600.   Remarks     - S is a string-type expression. INDEX is an integer-type
  601.                 expression. The result of type char is the INDEX'th character
  602.                 of S if INDEX is between 1 and Length(S) inclusive, otherwise
  603.                 it is an ASCII zero.
  604. ---------------------------------------------------------------------------}
  605.   BEGIN
  606.     IF (INDEX > Length(s)) THEN
  607.       ChOfStr := #0
  608.     ELSE
  609.       ChOfStr := s[INDEX];
  610. {}END {ChOfStr};
  611.  
  612.  
  613.  
  614.  
  615. {}FUNCTION  StrEnd(s:STRING):BYTE;
  616. {+H
  617. ---------------------------------------------------------------------------
  618.   Purpose     - Returns the position of the last non-white space char in S.
  619. ---------------------------------------------------------------------------}
  620.   VAR
  621.     L    : BYTE ABSOLUTE s;
  622.   BEGIN
  623.     WHILE (L>0) AND (s[L] IN [#$00..#$20]) DO
  624.       Dec(L);
  625.  
  626.     StrEnd := L;
  627. {}END {StrEnd};
  628.  
  629.  
  630.  
  631.  
  632. {}FUNCTION Squeeze(s:STRING):STRING;
  633. {+H
  634. ---------------------------------------------------------------------------
  635.   Purpose     - Squeeze out all control characters & white space from a string.
  636.   Declaration - Squeeze(s:STRING)
  637.   Result type - string.
  638. ---------------------------------------------------------------------------}
  639.   VAR
  640.     i    : INTEGER;
  641.     t    : STRING;
  642.     ch   : SET OF CHAR;
  643.   BEGIN
  644.     t := '';
  645.     ch:= [#0..#32,#127..#255];
  646.  
  647.     FOR i := 1 TO Length(s) DO
  648.       IF NOT (s[i] IN ch) THEN
  649.         t := t + s[i];
  650.  
  651.     Squeeze := t;
  652. {}END {Squeeze};
  653.  
  654.  
  655.  
  656.  
  657. {}FUNCTION Squeeze_ANP(s:STRING):STRING;
  658. {+H
  659. ---------------------------------------------------------------------------
  660.   Purpose     - Squeeze out all characters except letters, numbers, periods
  661.                 and underscores from a string.
  662.   Declaration - Squeeze_ANP(s:STRING)
  663.   Result type - string.
  664. ---------------------------------------------------------------------------}
  665.   VAR
  666.     i    : INTEGER;
  667.     t    : STRING;
  668.     ch   : SET OF CHAR;
  669.   BEGIN
  670.     t := '';
  671.     ch:= ['.','_','0'..'9','A'..'Z','a'..'z'];
  672.  
  673.     FOR i := 1 TO Length(s) DO
  674.       IF s[i] IN ch THEN
  675.         t := t + s[i];
  676.  
  677.     Squeeze_ANP := t;
  678. {}END {Squeeze_ANP};
  679.  
  680.  
  681.  
  682.  
  683. {}FUNCTION SqueezeAN(s:STRING):STRING;
  684. {+H
  685. ---------------------------------------------------------------------------
  686.   Purpose     - Squeeze out all non alpha numeric characters from a string.
  687.   Declaration - SqueezeAN(s:STRING)
  688.   Result type - string.
  689. ---------------------------------------------------------------------------}
  690.   VAR
  691.     i    : INTEGER;
  692.     t    : STRING;
  693.     ch   : SET OF CHAR;
  694.   BEGIN
  695.     t := '';
  696.     ch:= ['0'..'9','A'..'Z','a'..'z'];
  697.  
  698.     FOR i := 1 TO Length(s) DO
  699.       IF (s[i] IN ch) THEN
  700.         t := t + s[i];
  701.  
  702.     SqueezeAN := t;
  703. {}END {SqueezeAN};
  704.  
  705.  
  706.  
  707.  
  708. {}FUNCTION Reverse(s:STRING):STRING;
  709. {+H
  710. ---------------------------------------------------------------------------
  711.   Purpose     - Reverse the characters in a string.
  712.   Declaration - Reverse(s:STRING)
  713.   Result type - string.
  714. ---------------------------------------------------------------------------}
  715.   VAR
  716.     i    : INTEGER;
  717.     t    : STRING;
  718.     ch   : SET OF CHAR;
  719.   BEGIN
  720.     t := '';
  721.  
  722.     FOR i := 1 TO Length(s) DO
  723.       t := s[i] + t;
  724.  
  725.     Reverse := t;
  726. {}END {Reverse};
  727.  
  728.  
  729.  
  730.  
  731.               {------------------------------
  732.               {Formatting}
  733.  
  734.  
  735. {}FUNCTION PhoneStr(phone:STRING):STRING;
  736. {+H
  737. ---------------------------------------------------------------------------
  738.   Purpose     - Converts a compressed phone number to a formatted string
  739.                 containing just the local exchange.
  740.   Declaration - PhoneStr(phone:STRING)
  741.   Result type - string.
  742.   Example     - s := PhoneStr('7133332655');   s contains '333-2655'
  743. ---------------------------------------------------------------------------}
  744.   BEGIN
  745.     Phone := Copy(Phone,Length(Phone)-6,7);
  746.     PhoneStr := Copy(Phone,1,3)+'-'+Copy(phone,4,4);
  747. {}END {PhoneStr};
  748.  
  749.  
  750.  
  751.  
  752. {}FUNCTION FullPhoneStr(phone:STRING):STRING;
  753. {+H
  754. ---------------------------------------------------------------------------
  755.   Purpose     - Converts a compressed phone number to a formatted string
  756.                 containing the full phone number.
  757.   Declaration - FullPhoneStr(phone:STRING)
  758.   Result type - string.
  759.   Example     - s := FullPhoneStr('7133332655');   s contains '(713)333-2655'
  760. ---------------------------------------------------------------------------}
  761.   BEGIN
  762.     FullPhoneStr := '('+Copy(Phone,1,3)+')'+Copy(phone,4,3)+'-'+Copy(phone,7,4);
  763. {}END {FullPhoneStr};
  764.  
  765.  
  766.  
  767.  
  768. {}FUNCTION  PennyStr(Pennies:LongINT; MaxLen:BYTE; DollarSign:BOOLEAN):STRING;
  769. {+H
  770. ---------------------------------------------------------------------------
  771.   Purpose     - Convert a money amount (stored as the number of cents) to
  772.                 the standard US dollar convention.
  773.   Declaration - PennyStr(Pennies:LongINT; MaxLen:BYTE; DollarSign:BOOLEAN)
  774.   Result type - string.
  775.   Example     - s := PennyStr(23452,8,TRUE);  s contains ' $234.52'
  776. ---------------------------------------------------------------------------}
  777.   CONST    {....^....1....^....2}
  778.     mask = '#################.##';
  779.            {2....^....1....^....}
  780.   VAR
  781.     r    : FLOAT;
  782.     p    : BYTE;
  783.     m,t  : STRING;
  784.   BEGIN
  785.     IF DollarSign THEN
  786.       Dec(MaxLen);
  787.     p := 21 - MaxLen;
  788.     r := Pennies / 100.0;
  789.     m := Copy(mask,p,MaxLen);
  790.     IF DollarSign THEN
  791.       m := '$'+m;
  792.     t := TPString.Form(m,r);
  793.     PennyStr := t;
  794. {}END {PennyStr};
  795.  
  796.  
  797.  
  798.  
  799. {}FUNCTION  Cap1stChar(s:STRING):STRING;
  800. {+H
  801. ---------------------------------------------------------------------------
  802.   Purpose     - Capitalize the first letter in each occurance of a substring,
  803.                 where substrings are defined by the delimiters <space>,
  804.                 <comma>, <period>, <tab>, <(> and <->.
  805.   Declaration - Cap1stChar(s:STRING)
  806.   Result type - string.
  807.   Revised     - 1988.0822 (KSB) Added <(> to delimeters.
  808.               - 1992.0930 (KSB) Added <-> to delimeters.
  809. ---------------------------------------------------------------------------}
  810.   VAR
  811.     i    : WORD;
  812.     isDelimit : BOOLEAN;
  813.     wasDelimit: BOOLEAN;
  814.   BEGIN
  815.     wasDelimit := TRUE;
  816.     FOR i := 1 TO Length(s) DO BEGIN
  817.       isDelimit := (s[i] IN [' ',',','.',#09,'(','-']);    {1992.0930}
  818.  
  819.       IF wasDelimit AND (NOT isDelimit) THEN
  820.         s[i] := UpCase(s[i])
  821.       ELSE
  822.         s[i] := LoCase(s[i]);
  823.       wasDelimit := isDelimit;
  824.     END {FOR};
  825.     Cap1stChar := s;
  826. {}END {Cap1stChar};
  827.  
  828.  
  829.  
  830.  
  831. {}FUNCTION Plural(num:LongINT; thing:STRING):STRING;
  832. {+H
  833. ---------------------------------------------------------------------------
  834.   Purpose     - Convert a LongINT/Word/Integer/Byte/ShortInt to a string that
  835.                 that is followed by the pluralized descriptor THING.
  836.   Declaration - Plural(num:LongINT; thing:STRING)
  837.   Result type - string.
  838.   Example     - s := Plural(0,'baby');     s contains 'no babies'
  839.                 s := Plural(1,'bunny');    s contains '1 bunny'
  840.                 s := Plural(2,'dollar');   s contains '2 dollars'
  841. ---------------------------------------------------------------------------}
  842.   VAR
  843.     temp : STRING[10];
  844.     ch   : CHAR;
  845. {}{}FUNCTION Plurals:STRING;
  846.     BEGIN
  847.       ch := LastChar(thing);
  848.       IF UpCase(ch) = 'Y' THEN
  849.         Plurals := Copy(thing,1,Length(thing)-1)+'ies'
  850.       ELSE
  851.         Plurals := thing+'s'
  852. {}{}END {Plurals};
  853.  
  854.  
  855.   BEGIN
  856.     Str(num,temp);
  857.     CASE num OF
  858.       0 :  Plural := 'No '+Plurals;
  859.       1 :  Plural := '1 '+thing;
  860.       ELSE
  861.         Plural := temp+' '+Plurals;
  862.     END {CASE};
  863. {}END {Plural};
  864.  
  865.  
  866.  
  867.  
  868. {}FUNCTION Long2LStr(L:LongINT; width:BYTE):STRING;
  869. {+H
  870. ---------------------------------------------------------------------------
  871.   Purpose     - Convert a LongINT/Word/Integer/Byte/ShortInt to a string of
  872.                 at least WIDTH character, left padded with blanks if required.
  873.   Declaration - Long2LStr(L:LongINT; width:BYTE)
  874.   Result type - string.
  875.   Revised     - 1992.0423 (KSB) Used Str to convert L to S.
  876. ---------------------------------------------------------------------------}
  877.   VAR
  878.     s    : STRING;
  879.   BEGIN
  880.     Str(L,s);
  881.     Long2LStr := LeftPad(s,width);
  882. {}END {Long2LStr};
  883.  
  884.  
  885.  
  886.  
  887. {}FUNCTION  Long2Text(L:LongINT):STRING;
  888. {+H
  889. ---------------------------------------------------------------------------
  890.   Purpose     - Convert a LongINT/Word/Integer/Byte/ShortInt to a text string
  891.                 Long2Text always returns a positive value.
  892.   Declaration - Long2Text(L:LongINT)
  893.   Result type - string.
  894.   Example     - s := Long2Text(25);  s contains "Twenty five"
  895. ---------------------------------------------------------------------------}
  896.   CONST
  897.     ones : ARRAY[0..9]OF STRING[5]=
  898. ('zero','one','two','three','four','five','six','seven','eight','nine');
  899.     tenty: ARRAY[10..19]OF STRING[9]   =
  900. ('ten','eleven','twelve','thirteen','fourteen','fifteen','sixteen','seventeen','eighteen','nineteen');
  901.     tens : ARRAY[2..9]OF STRING[7]=
  902. ('twenty','thirty','fourty','fifty','sixty','seventy','eighty','ninety');
  903.     hundred   = ' hundred';
  904.     thousand  = ' thousand';
  905.     million   = ' million';
  906.     billion   = ' billion';
  907.  
  908. {}{}FUNCTION UpTo100(s:STRING):STRING;
  909.     VAR
  910.       t  : STRING;
  911.       L  : BYTE ABSOLUTE s;
  912.     BEGIN
  913.       t := '';
  914.       REPEAT
  915.         CASE L OF
  916.           1 :
  917.           IF s <> '0' THEN
  918.             t := t + ones[StringToLong(s)]
  919.           ELSE
  920.           IF t = '' THEN
  921.             t := t + ones[StringToLong(s)];
  922.  
  923.           2 :
  924.           CASE s[1] OF
  925.             '0' : ;
  926.             '1' :
  927.             BEGIN
  928.               t := t + tenty[StringToLong(s)] + ' ';
  929.               Delete(s,1,1);
  930.             END {BEGIN};
  931.             ELSE
  932.               t := t + tens[StringToLong(s[1])] + ' ';
  933.           END {CASE};
  934.  
  935.           3 : t := t + ones[StringToLong(s[1])] + hundred + ' ';
  936.         END {CASE};
  937.  
  938.         Delete(s,1,1);
  939.       UNTIL L = 0;
  940.  
  941.       UpTo100 := Trim(t);
  942. {}{}END {UpTo100};
  943.  
  944.  
  945.   VAR
  946.     s,t,u: STRING;
  947.     Len  : BYTE ABSOLUTE s;
  948.     i    : BYTE;
  949.   BEGIN
  950.     s := Long2Str(Abs(L));
  951.     t := '';
  952.  
  953.     REPEAT
  954.       CASE Len OF
  955.         0..3  : u := '';
  956.         4..6  : u := thousand;
  957.         7..9  : u := million;
  958.         10..12 : u := billion;
  959.       END {CASE};
  960.  
  961.       i := Len MOD 3;
  962.       IF (Len > 0) AND (i = 0) THEN
  963.         i := 3;
  964.  
  965.       t := t + UpTo100(Copy(s,1,i))+u + ' ';
  966.       Delete(s,1,i);
  967.     UNTIL Len=0;
  968.  
  969.     Long2Text := Trim(t);
  970. {}END {Long2Text};
  971.  
  972.  
  973.  
  974.  
  975. {}FUNCTION  BankStr(pennies:LongINT):STRING;
  976. {+H
  977. ---------------------------------------------------------------------------
  978.   Purpose     - Convert the number of pennies to a text description.  BankStr
  979.                 always returns a positive value.
  980.   Declaration - BankStr(pennies:LongINT)
  981.   Result type - string.
  982.   Example     - s := BankStr(45235);
  983.                 s contains "Four hundred fifty two dollars and thirty five cents"
  984. ---------------------------------------------------------------------------}
  985.   VAR
  986.     s,t  : STRING;
  987.     L    : BYTE ABSOLUTE s;
  988.   BEGIN
  989.     pennies := Abs(pennies);
  990.     s := Long2Str(pennies);
  991.     t := Copy(s,L-1,2);
  992.     s := Copy(s,1,L-2);
  993.  
  994.     BankStr := Long2Text(StringToLong(s))+' dollars and '+
  995.       Long2Text(StringToLong(t))+' cents';
  996. {}END {BankStr};
  997.  
  998.  
  999.  
  1000.  
  1001. {}FUNCTION WeightToLbOzStr(w:LongINT):STRING;
  1002. {+H
  1003. ---------------------------------------------------------------------------
  1004.   Purpose     - Display W (total ounces) in one of the following formats,
  1005.                 depending on the magnitude of W:
  1006.                   xxx:xx  for         0 to        15,999 ounces
  1007.                   xxxxx#  for    16,000 to     1,599,991 ounces
  1008.                   xxxxxT  for 1,599,992 to 2,147,483,647 ounces
  1009.   Declaration - WeightToLbOzStr(w:LongINT)
  1010.   Result type - string.
  1011.   Revised     - 1991.0414 (KSB) Wrote Initial Version.
  1012.               - 1991.0624 (KSB) Padded ounces with leading zeros.
  1013. ---------------------------------------------------------------------------}
  1014.   VAR
  1015.     ton  : WORD;
  1016.     Lb,oz: WORD;
  1017.   BEGIN
  1018.     Lb := w DIV 16;
  1019.     oz := w - (Lb*16);
  1020.  
  1021.     IF w < 16 THEN
  1022.       WeightToLbOzStr := '  0:'+ReplaceAll(Long2LStr(w,2),' ','0')
  1023.     ELSE
  1024.     IF w < 16000 THEN
  1025.       WeightToLbOzStr := Long2LStr(Lb,3)+':'+ReplaceAll(Long2LStr(oz,2),' ','0')
  1026.     ELSE
  1027.     IF w < 1599992 THEN
  1028.       WeightToLbOzStr := Long2LStr(lb,5)+'#'
  1029.     ELSE
  1030.       WeightToLbOzStr := Long2LStr((Lb DIV 2000),5)+'T'
  1031. {}END {WeightToLbOzStr};
  1032.  
  1033.  
  1034.  
  1035.  
  1036.               {------------------------------
  1037.               {Type Conversion}
  1038.  
  1039.  
  1040. {}FUNCTION  StringToLong(s:STRING):LongINT;
  1041. {+H
  1042. ---------------------------------------------------------------------------
  1043.   Purpose     - Convert a string representation of a number to a value.
  1044.   Declaration - StringToLong(s:STRING)
  1045.   Revised     - 1990.1216 (KSB) Wrote initial version.
  1046.               - 1992.0423 (KSB) Rewrote without reference to TP calls.
  1047. ---------------------------------------------------------------------------}
  1048.   VAR
  1049.     L    : LongINT;
  1050.     len  : BYTE ABSOLUTE s;
  1051.     c    : INTEGER;
  1052.   BEGIN
  1053.     WHILE s[len] = ' ' DO
  1054.       Dec(len);
  1055.     Val(s,L,c);
  1056.     IF c <> 0 THEN
  1057.       L := 0;
  1058.  
  1059.     StringToLong := L;
  1060. {}END {StringToLong};
  1061.  
  1062.  
  1063.  
  1064.  
  1065. {}PROCEDURE StringToArray(StrP:STRING; VAR CharArrayP; Len: BYTE);
  1066. {+H
  1067. ---------------------------------------------------------------------------
  1068.   Purpose     - converts a string to a character array of LEN.
  1069.   Declaration - StringToArray(StrP:STRING; VAR CharArrayP; Len: BYTE)
  1070.   Remarks     - Previously named StringConvert.
  1071. ---------------------------------------------------------------------------}
  1072.   TYPE
  1073.     ArrayType = ARRAY[1..80] OF CHAR;
  1074.   VAR
  1075.     chars: ArrayType ABSOLUTE CharArrayP;
  1076.     StrLen,
  1077.     i    : BYTE;
  1078.   BEGIN
  1079.     StrLen := Length(StrP);
  1080.     StrP   := StrP + CharStr(' ',Len - StrLen); {pad string with spaces to array Len}
  1081.     FOR i := 1 TO Len DO
  1082.       chars[i] := StrP[i];
  1083. {}END {StringToArray};
  1084.  
  1085.  
  1086.  
  1087.  
  1088. {}FUNCTION  ArrayToString(VAR CharArrayP; start:WORD; Len:BYTE):STRING;
  1089. {+H
  1090. ---------------------------------------------------------------------------
  1091.   Purpose     - Convert subelements of a character array, starting at position
  1092.                 START, into a string of length LEN.
  1093.   Declaration - ArrayToString(VAR CharArrayP; start:WORD; Len:BYTE)
  1094.   Result type - string.
  1095.   Remarks     - The user is responsible for determining that START+LEN does not
  1096.                 exceed the array bounds.
  1097.   Revised     - 1991.0613 (KSB) Wrote initial version.
  1098. ---------------------------------------------------------------------------}
  1099.   {$R-}
  1100.   TYPE
  1101.     ArrayType = ARRAY[1..1]OF CHAR;
  1102.   VAR
  1103.     chars: ArrayType ABSOLUTE CharArrayP;
  1104.     s    : STRING;
  1105.     i    : WORD;
  1106.   BEGIN
  1107.     FillChar(s,256,0);
  1108.     FOR i := 1 TO Len DO
  1109.       s[i] := chars[start+i-1];
  1110.  
  1111.     s[0] := CHAR(Len);
  1112.     ArrayToString := s;
  1113. {}END {ArrayToString};
  1114.  
  1115.  
  1116.  
  1117.  
  1118. {}FUNCTION  StringToReal(s:STRING):REAL;
  1119. {+H
  1120. ---------------------------------------------------------------------------
  1121.   Purpose     - Convert a string representation of a real number to a value.
  1122.   Declaration - StringToReal(s:STRING)
  1123.   Revised     - 1992.0407 (KSB) Wrote initial version.
  1124.               - 1992.0423 (KSB) Rewrote without reference to TP calls.
  1125. ---------------------------------------------------------------------------}
  1126.   VAR
  1127.     r    : REAL;
  1128.     len  : BYTE ABSOLUTE s;
  1129.     c    : INTEGER;
  1130.   BEGIN
  1131.     WHILE s[len] = ' ' DO
  1132.       Dec(len);
  1133.     Val(s,r,c);
  1134.     IF c <> 0 THEN
  1135.       r := 0;
  1136.  
  1137.     StringToReal := r;
  1138. {}END {StringToReal};
  1139.  
  1140.  
  1141.  
  1142.  
  1143. {}FUNCTION DollarsToPennies(s:STRING):LongINT;
  1144. {+H
  1145. ---------------------------------------------------------------------------
  1146.   Purpose     - Convert a string "$34.67" to 3467.
  1147.   Declaration - DollarsToPennies(s:STRING)
  1148.   Revised     - 1992.0423 (KSB) Rewrote.
  1149. ---------------------------------------------------------------------------}
  1150.   VAR
  1151.     r    : REAL;
  1152.     t    : STRING;
  1153.     L    : BYTE ABSOLUTE s;
  1154.   BEGIN
  1155.     s := Trim(s);
  1156.     IF s[1] = '$' THEN
  1157.       Delete(s,1,1);
  1158.  
  1159.     t := '';
  1160.     WHILE (L>0) AND (s[1] IN ['0'..'9','.']) DO BEGIN
  1161.       t := t + s[1];
  1162.       Delete(s,1,1);
  1163.     END {WHILE};
  1164.  
  1165.     DollarsToPennies := Round(StringToReal(t)*100);
  1166. {}END {DollarsToPennies};
  1167.  
  1168.  
  1169.  
  1170.  
  1171.               {------------------------------
  1172.               {Pattern Matching}
  1173.  
  1174.  
  1175. {}FUNCTION  Matches(s,pattern:STRING):BOOLEAN;
  1176. {+H
  1177. ---------------------------------------------------------------------------
  1178.   Purpose     - If pattern is found in S then return true.
  1179.   Declaration - Matches(s,pattern:STRING)
  1180.   Rules       - "a" matches A..Z, a..z
  1181.                 "9" matches 0..9
  1182.                 "8" matches 0..9 or trailing blanks.
  1183.                     Characters after 1st blank illegal
  1184.                "^A" matches beginning of line
  1185.                "^Z" matches end of line  (not implemented)
  1186.                 Uppercase alpha char matches that char, case insensitive
  1187.                 Other characters map to themselves.
  1188.   Revised     - 1990.09xx (KSB) Wrote initial version.
  1189.               - 1990.0920 (KSB) Added "8" rule.
  1190.               - 1991.0825 (KSB) Revised "8" Rule to allow S strings shorter
  1191.                 than the pattern.
  1192. ---------------------------------------------------------------------------}
  1193.   CONST
  1194.     mbeg = ^a;
  1195.     mend = ^z;
  1196.     alpha= 'a';
  1197.     numbr= '9';
  1198.     noblk= '8';
  1199.   VAR
  1200.     firstblank: BOOLEAN;
  1201.  
  1202. {}{}FUNCTION Match(s,pattern:STRING):BOOLEAN;
  1203.     VAR
  1204.       L  : BYTE ABSOLUTE s;
  1205.       m  : BYTE ABSOLUTE pattern;
  1206.       i  : INTEGER;
  1207.       ok : BOOLEAN;
  1208.     BEGIN
  1209.       Match := FALSE;
  1210.       FOR i := 1 TO m DO BEGIN
  1211.         CASE pattern[i] OF
  1212.           'a' : ok := s[i] IN ['A'..'Z','a'..'z'];
  1213.           '9' : ok := s[i] IN ['0'..'9'];
  1214.           '8' :
  1215.           BEGIN
  1216.             IF L<i THEN BEGIN        {1991.0825}
  1217.               Match := TRUE;
  1218.               Exit;
  1219.             END {IF};
  1220.  
  1221.             ok := s[i] IN ['0'..'9',' '];
  1222.             IF ok AND (s[i]=' ') THEN BEGIN
  1223.               ok := NOT firstBlank;
  1224.               firstBlank := TRUE;
  1225.             END {IF};
  1226.           END {BEGIN};
  1227.           ^z  : ok := L=Pred(i);
  1228.           ELSE
  1229.             ok := pattern[i]=UpCase(s[i]);
  1230.         END {CASE};
  1231.         IF NOT ok THEN
  1232.           Exit;
  1233.       END {FOR};
  1234.       Match := TRUE;
  1235. {}{}END {Match};
  1236.  
  1237.  
  1238.   VAR
  1239.     L    : BYTE ABSOLUTE s;
  1240.     m    : BYTE ABSOLUTE pattern;
  1241.     i,j  : INTEGER;
  1242.   BEGIN
  1243.     Matches := TRUE;
  1244.     IF m=0 THEN
  1245.       Exit;
  1246.     Matches := FALSE;
  1247.     IF L=0 THEN
  1248.       Exit;
  1249.  
  1250.     firstBlank := FALSE;
  1251.  
  1252.     s := StUpCase(s);
  1253.     IF pattern[1]= mbeg THEN BEGIN
  1254.       Matches := Match(s,Copy(pattern,2,m));
  1255.       Exit;
  1256.     END ELSE BEGIN
  1257.       IF L=m THEN BEGIN
  1258.         Matches := Match(s,pattern);
  1259.         Exit;
  1260.       END ELSE BEGIN
  1261.         i := L-m;
  1262.         IF i<0 THEN
  1263.           i := m;                      {1991.0825; was exit}
  1264.  
  1265.         FOR j:= 1 TO i DO
  1266.           IF Match(Copy(s,j,L),pattern) THEN BEGIN
  1267.             Matches := TRUE;
  1268.             Exit;
  1269.           END {IF};
  1270.       END {BEGIN};
  1271.     END {BEGIN};
  1272. {}END {Matches};
  1273.  
  1274.  
  1275.  
  1276.  
  1277. {}FUNCTION IsAfter(s1,s2,s:STRING):BOOLEAN;
  1278. {+H
  1279. ---------------------------------------------------------------------------
  1280.   Purpose     - Return true if S1 occurs after S2 in S.
  1281.   Declaration - IsAfter(s1,s2,s:STRING)
  1282.   Result type - boolean.
  1283.   Remarks     - S1, S2, and S are string-type expressions.  If substring S1
  1284.                 occurs in the string S after the substring S2, the function
  1285.                 will return true.
  1286. ---------------------------------------------------------------------------}
  1287.   VAR
  1288.     i,j  : BYTE;
  1289.   BEGIN
  1290.     i := Pos(s1,s);
  1291.     j := Pos(s2,s);
  1292.     IF (i=0) OR (j=0) OR (i <= j) THEN
  1293.       IsAfter := FALSE
  1294.     ELSE
  1295.       IsAfter := TRUE;
  1296. {}END {IsAfter};
  1297.  
  1298.  
  1299.  
  1300.  
  1301. {}FUNCTION IsBefore(s1,s2,s:STRING):BOOLEAN;
  1302. {+H
  1303. ---------------------------------------------------------------------------
  1304.   Purpose     - Return true if S1 occurs before S2 in S.
  1305.   Declaration - IsBefore(s1,s2,s:STRING)
  1306.   Result type - boolean.
  1307.   Remarks     - S1, S2, and S are string-type expressions.  If substring S1
  1308.                 occurs in the string S before the substring S2, the function
  1309.                 will return true.
  1310. ---------------------------------------------------------------------------}
  1311.   VAR
  1312.     i,j  : BYTE;
  1313.   BEGIN
  1314.     i := Pos(s1,s);
  1315.     j := Pos(s2,s);
  1316.     IF (i=0) OR (j=0) OR (i >= j) THEN
  1317.       IsBefore:= FALSE
  1318.     ELSE
  1319.       IsBefore:= TRUE;
  1320. {}END {IsBefore};
  1321.  
  1322.  
  1323.  
  1324.  
  1325. {}FUNCTION Indented(s:STRING):BYTE;
  1326. {+H
  1327. ---------------------------------------------------------------------------
  1328.   Purpose     - Returns number of leading white space characters in S.
  1329.   Declaration - Indented(s:STRING)
  1330.   Result type - byte.
  1331.   Remarks     - S is a string-type expression.  The function returns the
  1332.                 number of leading white space characters.
  1333. ---------------------------------------------------------------------------}
  1334.   VAR
  1335.     L    : BYTE ABSOLUTE s;
  1336.     i    : BYTE;
  1337.   BEGIN
  1338.     i := 1;
  1339.     WHILE (i < L) AND (s[i] IN [#0..#32]) DO
  1340.       Inc(i);
  1341.  
  1342.     Indented := Pred(i);
  1343. {}END {Indented};
  1344.  
  1345.  
  1346.  
  1347.  
  1348.               {------------------------------
  1349.               {Character testing}
  1350.  
  1351.  
  1352. {}FUNCTION IsLetter(c:CHAR):BOOLEAN;
  1353. {+H
  1354. ---------------------------------------------------------------------------
  1355.   Purpose     - Returns T if c a letter.
  1356.   Declaration - IsLetter(c:CHAR)
  1357.   Result type - boolean.
  1358. ---------------------------------------------------------------------------}
  1359.   BEGIN
  1360.     IsLetter := c IN ['A'..'Z','a'..'z'];
  1361. {}END {IsLetter};
  1362.  
  1363.  
  1364.  
  1365.  
  1366. {}FUNCTION IsLower(c:CHAR):BOOLEAN;
  1367. {+H
  1368. ---------------------------------------------------------------------------
  1369.   Purpose     - Returns T if c an lowercase letter.
  1370.   Declaration - IsLower(c:CHAR)
  1371.   Result type - boolean.
  1372. ---------------------------------------------------------------------------}
  1373.   BEGIN
  1374.     IsLower := c IN ['a'..'z'];
  1375. {}END {IsLower};
  1376.  
  1377.  
  1378.  
  1379.  
  1380. {}FUNCTION IsUpper(c:CHAR):BOOLEAN;
  1381. {+H
  1382. ---------------------------------------------------------------------------
  1383.   Purpose     - Returns T if c an uppercase letter.
  1384.   Declaration - IsUpper(c:CHAR)
  1385.   Result type - boolean.
  1386. ---------------------------------------------------------------------------}
  1387.   BEGIN
  1388.     IsUpper := c IN ['A'..'Z'];
  1389. {}END {IsUpper};
  1390.  
  1391.  
  1392.  
  1393.  
  1394. {*}
  1395.  
  1396.  
  1397. {}FUNCTION IsDigit(c:CHAR):BOOLEAN;
  1398. {+H
  1399. ---------------------------------------------------------------------------
  1400.   Purpose     - Returns T if c is a digit.
  1401.   Declaration - IsDigit(c:CHAR)
  1402.   Result type - boolean.
  1403. ---------------------------------------------------------------------------}
  1404.   BEGIN
  1405.     IsDigit := c IN ['0'..'9'];
  1406. {}END {IsDigit};
  1407.  
  1408.  
  1409.  
  1410.  
  1411. {}FUNCTION IsHexDigit(c:CHAR):BOOLEAN;
  1412. {+H
  1413. ---------------------------------------------------------------------------
  1414.   Purpose     - Returns T if c is a hexidecimal digit.
  1415.   Declaration - IsHexDigit(c:CHAR)
  1416.   Result type - boolean.
  1417. ---------------------------------------------------------------------------}
  1418.   BEGIN
  1419.     IsHexDigit := c IN ['0'..'9','A'..'F','a'..'f'];
  1420. {}END {IsHexDigit};
  1421.  
  1422.  
  1423.  
  1424.  
  1425. {*}
  1426.  
  1427.  
  1428. {}FUNCTION IsAlphaNum(c:CHAR):BOOLEAN;
  1429. {+H
  1430. ---------------------------------------------------------------------------
  1431.   Purpose     - Returns T if c a letter or digit.
  1432.   Declaration - IsAlphaNum(c:CHAR)
  1433.   Result type - boolean.
  1434. ---------------------------------------------------------------------------}
  1435.   BEGIN
  1436.     IsAlphaNum := c IN ['A'..'Z','a'..'z','0'..'9'];
  1437. {}END {IsAlphaNum};
  1438.  
  1439.  
  1440.  
  1441.  
  1442. {}FUNCTION IsAscii(c:CHAR):BOOLEAN;
  1443. {+H
  1444. ---------------------------------------------------------------------------
  1445.   Purpose     - Returns T if c is in standard ASCII set.
  1446.   Declaration - IsAscii(c:CHAR)
  1447.   Result type - boolean.
  1448. ---------------------------------------------------------------------------}
  1449.   BEGIN
  1450.     IsAscii := c IN [#000..#127];
  1451. {}END {IsAscii};
  1452.  
  1453.  
  1454.  
  1455.  
  1456. {}FUNCTION IsCntrl(c:CHAR):BOOLEAN;
  1457. {+H
  1458. ---------------------------------------------------------------------------
  1459.   Purpose     - Returns T if c is a control character or delete.
  1460.   Declaration - IsCntrl(c:CHAR)
  1461.   Result type - boolean.
  1462. ---------------------------------------------------------------------------}
  1463.   BEGIN
  1464.     IsCntrl := c IN [#0..#31,#127];
  1465. {}END {IsCntrl};
  1466.  
  1467.  
  1468.  
  1469.  
  1470. {}FUNCTION IsExtended(c:CHAR):BOOLEAN;
  1471. {+H
  1472. ---------------------------------------------------------------------------
  1473.   Purpose     - Returns T if c is a member of the extended ASCII set.
  1474.   Declaration - IsExtended(c:CHAR)
  1475.   Result type - boolean.
  1476. ---------------------------------------------------------------------------}
  1477.   BEGIN
  1478.     IsExtended := c IN [#128..#255];
  1479. {}END {IsExtended};
  1480.  
  1481.  
  1482.  
  1483.  
  1484. {}FUNCTION IsPrint(c:CHAR):BOOLEAN;
  1485. {+H
  1486. ---------------------------------------------------------------------------
  1487.   Purpose     - Returns T if c is a printing character in the standard ASCII set.
  1488.   Declaration - IsPrint(c:CHAR)
  1489.   Result type - boolean.
  1490. ---------------------------------------------------------------------------}
  1491.   BEGIN
  1492.     IsPrint := c IN [#032..#126];
  1493. {}END {IsPrint};
  1494.  
  1495.  
  1496.  
  1497.  
  1498. {}FUNCTION IsPunct(c:CHAR):BOOLEAN;
  1499. {+H
  1500. ---------------------------------------------------------------------------
  1501.   Purpose     - Returns T if c is a punctuation character.
  1502.   Declaration - IsPunct(c:CHAR)
  1503.   Result type - boolean.
  1504. ---------------------------------------------------------------------------}
  1505.   BEGIN
  1506.     IsPunct := NOT(IsAlphaNum(c) OR IsCntrl(c) OR IsExtended(c));
  1507. {}END {IsPunct};
  1508.  
  1509.  
  1510.  
  1511.  
  1512. {}FUNCTION IsSpace(c:CHAR):BOOLEAN;
  1513. {+H
  1514. ---------------------------------------------------------------------------
  1515.   Purpose     - Returns T if c is a white space char. (tab, linefeed, vert.tab, formfeed, CR, space)
  1516.   Declaration - IsSpace(c:CHAR)
  1517.   Result type - boolean.
  1518. ---------------------------------------------------------------------------}
  1519.   BEGIN
  1520.     IsSpace := c IN [#009..#013,#032];
  1521. {}END {IsSpace};
  1522.  
  1523.  
  1524.  
  1525.  
  1526.               {------------------------------
  1527.               {Other}
  1528.  
  1529.  
  1530. {}FUNCTION  InSet(VAR someSet; VAR setMember):BOOLEAN;
  1531. {+H
  1532. ---------------------------------------------------------------------------
  1533.   Purpose     - If SOMESET is not empty, InSet extracts the lowest set member
  1534.                 from the set and returns True.  If SOMESET is empty, InSet
  1535.                 returns False.
  1536.   Declaration - InSet(VAR someSet; VAR setMember)
  1537.   Result type - boolean.
  1538.   Warning     - This function modifies its arguments, ie., it lacks idempotency.
  1539.   Revised     - 1991.0614 (KSB) Wrote initial version.
  1540.   Example:
  1541.     var  chars : set of char;   c : char;
  1542.     begin
  1543.       chars := ['A','E','I','O','U'];
  1544.       while InSet(chars,c) do ...
  1545.     end;
  1546. ---------------------------------------------------------------------------}
  1547.   TYPE
  1548.     SetType   = SET OF BYTE;
  1549.   VAR
  1550.     baseSet   : SetType ABSOLUTE someSet;
  1551.     mmbr : BYTE ABSOLUTE setMember;
  1552.   BEGIN
  1553.     InSet := FALSE;
  1554.     mmbr  := 255;
  1555.  
  1556.     REPEAT
  1557.       IF baseSet = [] THEN
  1558.         Exit;
  1559.  
  1560.       Inc(mmbr);
  1561.       IF (mmbr IN baseSet) THEN BEGIN
  1562.         baseSet := baseSet - [mmbr];
  1563.         InSet   := TRUE;
  1564.         Exit;
  1565.       END {IF};
  1566.     UNTIL mmbr = 255;
  1567. {}END {InSet};
  1568.  
  1569.  
  1570.  
  1571.  
  1572. {}FUNCTION CountOf(s:STRING; cs:CharSet):BYTE;
  1573. {+H
  1574. ---------------------------------------------------------------------------
  1575.   Purpose     - Count the number of CS characters in S.
  1576.   Declaration - CountOf(s:STRING; cs:CharSet)
  1577.   Result type - byte.
  1578. ---------------------------------------------------------------------------}
  1579.   VAR
  1580.     L    : BYTE ABSOLUTE s;
  1581.     i    : WORD;
  1582.     count: WORD;
  1583.   BEGIN
  1584.     count := 0;
  1585.  
  1586.     IF (cs <> []) THEN
  1587.       FOR i := 1 TO L DO
  1588.         IF s[i] IN cs THEN
  1589.           Inc(count);
  1590.  
  1591.     CountOf := count;
  1592. {}END {CountOf};
  1593.  
  1594.  
  1595.  
  1596.  
  1597. BEGIN
  1598. END {BEGIN}.
  1599.